home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1994 November: Tool Chest / Dev.CD Nov 94.toast / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / AppleScript-from-lisp / high-level-event-patch.lisp < prev    next >
Encoding:
Text File  |  1994-09-14  |  5.9 KB  |  120 lines  |  [TEXT/CCL2]
  1. (in-package ccl)
  2.  
  3. (let ((*warn-if-redefine-kernel* nil))
  4.   ; Tests to see if a handler exists for the given apple event.  - NJW 8/1/94
  5.   (defun get-handler (theAppleEvent)
  6.     (handler-bind ((error #'(lambda (x) (declare (ignore x)) nil)))
  7.       (let* ((class (ae-get-attribute-type theAppleEvent #$keyEventClassAttr))
  8.              (id (ae-get-attribute-type theAppleEvent #$keyEventIDAttr))
  9.              (id-table (gethash class %appleevent-handlers%)))
  10.         (unless id-table
  11.           (setq id-table (gethash :|****| %appleevent-handlers%)))
  12.         (and id-table (gethash id id-table)))))
  13.   
  14.   
  15.   ; defer-appleevent-handler is handles all appleevents & simply suspends the event
  16.   ; and appends the cons of the event, reply, and refcon to *deferred-appleevents*
  17.   ; If the event is from MCL itself, it handles it right away.
  18.   
  19.   
  20.   (defpascal defer-appleevent-handler (:pointer theAppleEvent :pointer reply
  21.                                                 :long handlerRefcon :word)
  22.     (declare (ignore handlerRefcon))
  23.     (rlet ((source :word)
  24.            (actualType :long)
  25.            (actualSize :long))
  26.       (if (or *inside-aesend*
  27.               (and
  28.                (eql #$noErr (#_AEGetAttributePtr
  29.                              theAppleEvent #$keyEventSourceAttr #$TypeShortInteger
  30.                  actualType source 2 actualSize))
  31.                (let ((source (%get-word source)))
  32.                  (or (eql #$kAESameProcess source)
  33.                      (eql #$kAEDirectCall source)
  34.              ; If handler doesn't exist then don't suspend.  Otherwise AppleScript
  35.              ; gets confused.  - NJW 8/1/94
  36.                      (null (get-handler theAppleEvent))))))
  37.         (do-appleevent theAppleEvent reply nil)
  38.         (progn
  39.           (ae-error (#_AESuspendTheCurrentEvent theAppleEvent))
  40.           (setq *deferred-appleevents*
  41.             (nconc *deferred-appleevents*
  42.                (cheap-cons (cheap-cons (copy-record theAppleEvent :aedesc)
  43.                            (copy-record reply :aedesc))
  44.                    nil)))
  45.       ; I'm not absolutely sure that this is the correct result in this case,
  46.       ; but we will assume it is.  - NJW 8/1/94
  47.           #$noErr))))
  48.   
  49.   ; (mcl 2.0p2)
  50.   (defun do-appleevent (theAppleEvent reply deferred-p)
  51.     (let ((result #$noErr)
  52.           (class nil)
  53.           (id nil)
  54.           (resumed? nil)
  55.       (handler nil))
  56.       (block buck-stops-here              ; don't throw past here unless (and
  57.         ; deferred-p *signal-applevent-errors*) 
  58.         (labels ((resume-appleevent ()
  59.                    (unless resumed?
  60.                      (setq resumed? t)
  61.                      ; try to put the result code in the reply (the reply may be null)
  62.                      ; if the event is itself a reply!
  63.                      ; The following line was removed since it causes
  64.                      ; AEProcessAppleEvent to fail when
  65.                      ; the AppleEvent is an AppleScript Scripting Addition.  MCL
  66.                      ; should not be adding to the reply if it doesn't handle the
  67.                      ; event.  - NJW 7/27/94 
  68.                      (if handler
  69.                        (ae-put-parameter-longinteger reply #$keyErrorNumber result nil))
  70.                      (when deferred-p
  71.                        (#_AEResumeTheCurrentEvent theAppleEvent reply
  72.                         (%int-to-ptr #$kAENoDispatch) 0)
  73.                        (dispose-record theAppleEvent)
  74.                        (dispose-record reply)
  75.                        (when *appleevent-quit*
  76.                          (setq *appleevent-quit* nil)   ; don't repeat if aborted out
  77.                          (quit)))))
  78.                  (error-handler (c)
  79.                    ; Removed based on the principle as in resume-appleevent.  However, this
  80.                    ; addition does not stop AEProcessAppleEvent, possibly because it is effecting
  81.                    ; 'theAppleEvent' rather than 'reply'.  - NJW 7/27/94
  82.                    (if handler
  83.                      (ae-put-parameter-char theAppleEvent #$keyErrorString
  84.                                             (with-output-to-string (s)
  85.                                               (report-condition c s))
  86.                                             nil))
  87.                    (if (typep c 'appleevent-error)
  88.                      (setq result (oserr c))    ; return the error to the AppleEvent Manager
  89.                      (setq result #$errAEEventNotHandled))
  90.                    (resume-appleevent)
  91.                    (unless (and deferred-p *signal-appleevent-errors*)
  92.                      (when *report-appleevent-errors*
  93.                        (format *error-output* "~%> Error while handling AppleEvent: '~a' '~a'~%> "
  94.                                class id)
  95.                        (report-condition c *error-output*))
  96.                      (return-from buck-stops-here))))
  97.           (declare (dynamic-extent #'resume-appleevent #'error-handler))
  98.           (unwind-protect                     ; make sure we resume the AppleEvent if deferred-p
  99.             (handler-bind ((error #'error-handler))
  100.               (setq class (ae-get-attribute-type theAppleEvent
  101.                                                  #$keyEventClassAttr)
  102.                     id (ae-get-attribute-type theAppleEvent #$keyEventIDAttr))
  103.               (let ((id-table (gethash class %appleevent-handlers%)))
  104.                 (unless id-table
  105.                   (setq id-table (gethash :|****| %appleevent-handlers%)))
  106.                 (setq handler (and id-table (gethash id id-table)))
  107.                 (unless handler
  108.                   (error (make-condition 'appleevent-error :oserr #$errAEEventNotHandled
  109.                                          :error-string (format nil "No Lisp Handler for '~a' '~a'"
  110.                                                                class id))))
  111.                 (funcall (car handler) *application* theAppleEvent reply (cdr handler))))
  112.             (resume-appleevent)
  113.             (unless (and deferred-p *signal-appleevent-errors*)
  114.               (return-from buck-stops-here)))))
  115.       result))
  116.   )
  117.  
  118.  
  119.  
  120.